; ------------------------------------
; EU-Rent
; Matus Tejiscak <ziman@functor.sk>
; Reasoning with computer support 2011
; ------------------------------------
;
; Purpose: Based on historical records, this system will decide whether
; a customer is eligible to rent a car.
;
; The secondary purpose is to recognize and print other interesting facts,
; such as late returns or automatic blacklisting.

; Templates
(deftemplate event  ; an item in the history (rental, reservation, ...)
  (slot seq)    ; sequence number
  (slot date)   ; timestamp, linear, in days
)

(deftemplate blacklist extends event
  (slot customer-name)
  (slot reason)
)

(deftemplate request extends event  ; an abstract request (reservation/query)
  (slot customer-name)
  (slot from-date)      ; proposed start date of rental
  (slot days)           ; proposed length of rental
)

(deftemplate can-rent? extends request
  (slot answer)   ; boolean answer
  (slot reason)
)

(deftemplate reservation extends request)

(deftemplate rental extends event
  (slot customer-name)
  (slot dropoff-event-seq)  ; the coresponding dropoff seq#
  (slot until)              ; proposed end date
)

(deftemplate reserved-rental extends rental
  (slot reservation-seq)    ; the corresponding reservation seq#
)

(deftemplate walkin-rental extends rental
  (slot days)   ; proposed rental length
)

(deftemplate drop-off extends event
  (slot customer-name)
  (slot rental-seq)   ; the corresponding rental
  (slot days-late)    ; positive if returned late, negative if returned early
  (slot condition (default good)) ; good or bad
)

(deftemplate dump-answers ; used to dump answers sequentially
  (slot seq)   ; current seq# to dump
)

(deftemplate trouble
  (slot seq)              ; the corresponding event
  (slot customer-name)
  (slot score)            ; "badness" of the trouble
  (slot total-score)      ; sum of scores up to now, including this trouble
  (slot previous-trouble) ; last committed trouble (or zero if first)
)

; === Rules ===

; penalties
(defglobal
  ?*day-late-score*    = 20   ; for returning a day late
  ?*day-early-score*   = 5    ; for returning a day too early
  ?*bad-cond-score*    = 50   ; for bad condition
  ?*noshow-score*      = 30   ; for not showing up
  ?*trouble-threshold* = 100  ; this much trouble gets you on the blacklist
)

; dumping rules
(defrule dump-positive
  "print positive answers"
  (dump-answers (seq ?seq))
  ?q <- (can-rent? (seq ?seq) (answer TRUE | nil)
    (customer-name ?cust) (seq ?seq))
  =>
  (printout t ?seq ": " ?cust " can safely rent a car." crlf)
)

(defrule dump-negative
  "print negative answers"
  (dump-answers (seq ?seq))
  ?q <- (can-rent? (seq ?seq) (answer FALSE) (reason ?reason)
    (customer-name ?cust) (seq ?seq))
  =>
  (printout t ?seq ": " ?cust " can NOT rent a car: " ?reason crlf)
)

(defrule dump-late-dropoffs
  "print late returns"
  (dump-answers (seq ?seq))
  (drop-off (seq ?seq) (days-late ?delta &: (neq ?delta nil) &: (> ?delta 0))
    (customer-name ?cust))
  =>
  (printout t ?seq ": This is a late drop-off. "
    "Charge " ?cust " for " ?delta " extra day(s)." crlf)
)

(defrule dump-early-dropoffs
  "print early returns"
  (dump-answers (seq ?seq))
  (drop-off (seq ?seq) (days-late ?delta &: (neq ?delta nil) &: (< ?delta 0))
    (customer-name ?cust))
  =>
  (printout t ?seq ": " ?cust " returned the car "
    (- 0 ?delta) " days too early." crlf)
)

(defrule dump-blacklists
  "print blacklist entries"
  (dump-answers (seq ?seq))
  (blacklist (seq ?seq) (customer-name ?cust) (reason ?reason))
  =>
  (printout t ?seq ": " ?cust " has been blacklisted: " ?reason crlf)
)

(defrule dump-noshow
  "print noshow reservations"
  (dump-answers (seq ?seq))
  (reservation (seq ?seq) (customer-name ?cust))
  (trouble (seq ?seq) (customer-name ?cust))
  =>
  (printout t ?seq ": " ?cust " did not show up for the reservation. "
    "Charge him." crlf)
)

(defrule dump-trouble
  "print all troubles"  ; too verbose, disabled
  (dump-answers (seq ?seq))
  (trouble (seq ?seq) (score ?score) (total-score ?total)
    (customer-name ?cust))
  =>
  ;(printout t ?seq ": " ?cust " earned " ?score " points of trouble, "
  ;  ?total " pts in total." crlf)
)

; can-rent rules
(defrule can-rent-blacklist
  "a blacklisted person can't rent"
  ?q <- (can-rent? (seq ?seqa) (customer-name ?cust))
  (blacklist (seq ?seqb &: (< ?seqb ?seqa)) (customer-name ?cust))
  =>
  (modify ?q (answer FALSE) (reason "blacklisted"))
)

(defrule can-rent-multiple
  "a person cannot rent a car while already having another one"
  ?q <- (can-rent? (seq ?seqa) (customer-name ?cust) (answer nil))
  (rental (seq ?seqb &: (< ?seqb ?seqa)) (customer-name ?cust)
    (dropoff-event-seq 0 | ?x&:(neq ?x nil)&:(> ?x ?seqa)))
  =>
  (modify ?q (answer FALSE) (reason "previous car not returned yet"))
)

; rental-related rules
(defrule rental-until-walkin
  "auto-calculate `until' for walk-ins"
  ?r <- (walkin-rental (date ?date) (days ?days) (until nil))
  =>
  (modify ?r (until (+ ?date ?days)))
)

(defrule rental-until-reserved
  "auto-calculate `until' for reserved rentals"
  ?r <- (reserved-rental (reservation-seq ?seq) (until nil))
  (reservation (seq ?seq) (from-date ?from) (days ?days))
  =>
  (modify ?r (until (+ ?from ?days)))
)

(defrule dropoff-binder-handler
  "connect dropoffs with the corresponding rentals"
  ?r <- (rental (seq ?seqa) (until ?until &: (neq ?until nil))
    (dropoff-event-seq nil) (customer-name ?cust))
  ?d <- (drop-off (seq ?seqb &: (> ?seqb ?seqa)) (date ?ddate)
    (rental-seq nil) (customer-name ?cust))
  (not (drop-off (seq ?dseq &: (> ?dseq ?seqa) &: (< ?dseq ?seqb))
    (customer-name ?cust)))
  (not (rental (seq ?rseq &: (> ?rseq ?seqa) &: (< ?rseq ?seqb))
    (customer-name ?cust)))
  =>
  (modify ?r (dropoff-event-seq ?seqb))
  (modify ?d (rental-seq ?seqa) (days-late (- ?ddate ?until)))
)

(defrule dropoff-missing
  "detect not-yet-returned cars"
  ?r <- (rental (seq ?seqa) (customer-name ?cust))
  (not (drop-off (seq ?seqb &: (> ?seqb ?seqa)) (customer-name ?cust)))
  =>
  (modify ?r (dropoff-event-seq 0))
)

; trouble-related rules
(deffunction trouble-score (?delta ?condition)
  "calculate trouble score given the delta and condition"
  (if (> ?delta 0)
    then (bind ?dscore (* ?delta ?*day-late-score*))
    else (bind ?dscore (* (- 0 ?delta) ?*day-early-score*)))
  (if (eq ?condition bad)
    then (bind ?cscore ?*bad-cond-score*)
    else (bind ?cscore   0))
  (return (+ ?dscore ?cscore))
)

(defrule trouble-noshow
  "create troubles for noshows"
  ?r <- (reservation (seq ?seq) (customer-name ?cust) (from-date ?from))
  (not (rental (seq ?rseq &: (> ?rseq ?seq))
    (customer-name ?cust) (date ?from)))
  =>
  (assert (trouble (seq ?seq) (customer-name ?cust) (score ?*noshow-score*)))
)

(defrule trouble-dropoff
  "create troubles for bad dropoffs"
  (drop-off (seq ?seq) (days-late ?delta &: (neq ?delta nil))
    (customer-name ?cust) (condition ?cond &:
      (> (trouble-score ?delta ?cond) 0)))
  =>
  (assert (trouble (seq ?seq) (customer-name ?cust)
    (score (trouble-score ?delta ?cond))))
)

(defrule trouble-accumulation
  "calculate sum of troubles"
  ?t <- (trouble (seq ?seq) (previous-trouble nil)
    (score ?score) (customer-name ?cust))
  (trouble (seq ?tseq &: (< ?tseq ?seq)) (customer-name ?cust)
    (total-score ?total &: (neq ?total nil)))
  (not (trouble (seq ?iseq &: (< ?iseq ?seq) &: (> ?iseq ?tseq))
    (customer-name ?cust)))
  =>
  (modify ?t (total-score (+ ?total ?score)))
)

(defrule trouble-init
  "evaluate the first trouble"
  ?t <- (trouble (seq ?tseq) (previous-trouble nil)
    (score ?score) (customer-name ?cust))
  (not (trouble (seq ?seq &: (< ?seq ?tseq)) (customer-name ?cust)))
  =>
  (modify ?t (total-score ?score))
)

; blacklisting
(defrule trouble-blacklist
  "blacklist customers causing too much trouble"
  (trouble (seq ?seq) (customer-name ?cust)
    (total-score ?total &: (neq ?total nil)
      &: (>= ?total ?*trouble-threshold*)))
  =>
  (assert (blacklist (seq ?seq) (customer-name ?cust)
    (reason "too much trouble")))
)

(defrule blacklist-prune
  "one blacklist is enough"
  (blacklist (seq ?seqa) (customer-name ?cust))
  ?q <- (blacklist (seq ?seqb &: (> ?seqb ?seqa)) (customer-name ?cust))
  =>
  (retract ?q)
)

; History
(deffacts records
  (blacklist
    (seq  1) (date  1) (customer-name "Evil Joe") (reason "known bad boy"))
  (can-rent?
    (seq  2) (date  2) (customer-name "Evil Joe") (from-date 2) (days 5))
  (can-rent?
    (seq  3) (date  2) (customer-name "Mary Lou") (from-date 4) (days 5))
  (reservation
    (seq  4) (date  2) (customer-name "Mary Lou") (from-date 3) (days 5))
  (reserved-rental
    (seq  5) (date  3) (customer-name "Mary Lou") (reservation-seq 4))
  (walkin-rental
    (seq  6) (date  4) (customer-name "John Qik") (days 20))
  (can-rent?
    (seq  7) (date  4) (customer-name "Mary Lou") (from-date 4) (days 5))
  (drop-off
    (seq  8) (date  9) (customer-name "Mary Lou"))
  (drop-off
    (seq  9) (date 10) (customer-name "John Qik"))
  (walkin-rental
    (seq 10) (date 10) (customer-name "Mary Lou") (days 1))
  (drop-off
    (seq 11) (date 12) (customer-name "Mary Lou") (condition bad))
  (walkin-rental
    (seq 12) (date 13) (customer-name "Mary Lou") (days 1))
  (drop-off
    (seq 13) (date 15) (customer-name "Mary Lou"))
  (can-rent?
    (seq 14) (date 16) (customer-name "Mary Lou") (from-date 16) (days 5))
  (reservation
    (seq 15) (date 17) (customer-name "John Qik") (from-date 17) (days 5))
  (can-rent?
    (seq 16) (date 17) (customer-name "John Qik"))
)

; Inference machinery
(reset)
(printout t crlf "Running the inference engine..." crlf)
(run)
(printout t crlf "===== Output of the program =====" crlf crlf)
(deffunction dump (?i)
  (if (> ?i 1) then (dump (- ?i 1)))
  (bind ?q (assert (dump-answers (seq ?i))))
  (run)
  (retract ?q)
)
(dump 30)
;(printout t crlf "===== Final facts =====" crlf crlf)
;(facts)
